home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-zelk / FORMIPS.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-12  |  15.5 KB  |  505 lines
  1. /*FORMIPS.c zilla 17apr - mips foreign function, c portion. c.f. MIPSASM.s
  2.  *
  3.  * !! this file gets INCLUDED in forfunc.c !!
  4.  * modified
  5.  * 22sep
  6.  *
  7.  * MIPS argument passing behavior:  char,short are always passed as
  8.  * 32bit ints regardless of whether prototypes are in use.
  9.  * Floats are returned as floats rather than doubles if ansi or -prototypes(?).
  10.  * Floats are passed as floats rather than doubles if -prototypes,
  11.  * or if -ansi and the function is written in prototype form.
  12.  * Thus,
  13.  *   void sub(float);
  14.  *   sub(f) float f; {...
  15.  * will receive a float under non-ansi C, but a double under ansi!; 
  16.  *   sub(float f) {..
  17.  * will receive a float in either case.
  18.  *
  19.  * "F" foreign arguments are passed double; declare float arguments as "f".
  20.  *
  21.  * If float (not double) stops working, be sure code is compiled
  22.  * with ansi or -prototypes.
  23.  *
  24.  * Approach of this code: C code assembles a mirror of the registers/
  25.  * floating registers/stack in normal C data structures FA_*;
  26.  * an assembler subroutine then copies these onto the actual registers&c.
  27.  *
  28.  * From David Frederick, thefred@csd.sgi.com:
  29.  
  30. An aside:  The stack pointer is *always* double word aligned.
  31. No exceptions.
  32.  
  33. Passing Arguments:
  34.  
  35. General registers $4..$7 and floating point registers $f12 and $f14
  36. pass the first few arguments in registers.  Double precision floating-point
  37. arguments are passed in the register pairs $f12,$f13 and $f14,$f15;
  38. single precision floating point arguments are passed in registers $f12 and
  39. $f14.
  40.  
  41. In determining which register, if any, an argument goes into, take into
  42. account the following considerations:
  43.         1) All integer-valued arguments are passed as 32-bit words,
  44.         with signed or unsigned bytes and halfwords expanded (promoted)
  45.         as necessare.
  46.  
  47.         2) If the called function returns a structure or union, the caller
  48.         passes the address of an area that is large enough to hold the
  49.         structure in $4.    The called function copies the returned structure
  50.         into this area before it returns.  This address becomes the first
  51.         argument to the function for the purposes of argument register
  52.         allocation and all user arguments are shifted down by one.
  53.  
  54.         3) Despite the fact that some or all arguments are passed in
  55.         registers, always allocate space on the stack for all arguments.
  56.         This stack space should be a a structure large enough to
  57.         contain all the arguments, aligned according to normal structure
  58.         rules (after promotion and structure return pointer insertion).
  59.         The locations within the stack frame used for arguments are
  60.         called the ``home locations.''
  61.  
  62.         4) Arguments declared in variable argument lists, for instance those
  63.         defined with a va_list declaration, are passed in the integer
  64.         registers if possible.  This is true even if the arguments are
  65.         floating-point values.  (For known varargs functions, current code
  66.         generation puts the initial fp values in *both* regular and
  67.         fp registers).
  68.  
  69.         5) When the first argument is integral, the remaining arguments
  70.         are passed in the integral registers.
  71.  
  72.         6) Structures are passed as if they were very wide integers with
  73.         their size rounded up to an integral number of words.  The fill
  74.         bits necessary for rounding up are undefined.
  75.  
  76.         A structure can be split so a portion is passed in registers and
  77.         the remainder passed on the stack.  In this case, the first
  78.         words are passed in $4,$5,$6,$7 as neede with additional words
  79.         passed on the stack.
  80.  
  81.         7) Unions are considered structures.
  82.  
  83. The rules that determine which arguments go into registers and which ones
  84. must be passed on the stack are most easily explained by considering the list
  85. of arguments as a structure, aligned according to normal structure rules.
  86. Mapping of this structure into the combination of stack and registers is as
  87. follows: uop to two leading floating-point (but not va_alist) arguments
  88. can be passed in $f12 and $f14.  Everything else with a structure offset
  89. greater than or equal to 16 is passed on the stack.  The remainder of the
  90. arguments are passed in $4..$7 based on their struture offset.  Holes
  91. left in the structure for alignment are unused, whether in registers or
  92. on the stack.
  93.  
  94. The following examples give a representative sampling of the mix of
  95. registes and stack used for passing arguments, where d represents
  96. double-precision floating-point values, s represents single-precision
  97. floating-point values, and n represents integers or pointers. The
  98. list is not exhaustive.
  99.  
  100.  
  101. Argument List                   Register and stack assignments
  102. -------------                   -----------------------------
  103. d1,d2                           $f12,$f14
  104. s1,s2                           $f12,$f14
  105. s1,d1                           $f12,$f14
  106. d1,s1                           $f12,$f14
  107. n1,n2,n3,n4                     $4,$5,$6,$7
  108. d1,n1,d2                        $f12,$6,stack
  109. d1,n1,n2                        $f12,$6,$7
  110. s1,n1,n2                        $f12,$5,$6
  111. n1,n2,n3,d1                     $4,$5,$6,stack
  112. n1,n2,n3,s1                     $4,$5,$6,$7
  113. n1,n2,d1                        $4,$5,($6,$7)
  114. n1,d1                           $4,($6,$7)
  115. s1,s2,s3,s4                     $f12,$f14,$6,$7
  116. s1,n1,s2,n2                     $f12,$5,$6,$7
  117. d1,s1,s2                        $f12,$f14,$6
  118. s1,s1,d1                        $f12,$f14,($6,$7)
  119. n1,s1,n2,s2                     $4,$5,$6,$7
  120. n1,s1,n2,n3                     $4,$5,$6,$7
  121. n1,n2,s1,n3                     $4,$5,$6,$7
  122.  
  123.  
  124. Function Return Values:
  125.  
  126. A function can return no value, an integral or pointer value, a
  127. floating-point value, or a structure; unions are treated the same
  128. as structures.
  129.  
  130. A function that returns no value puts no particular value in any
  131. register.
  132.  
  133. A function that returns an integral or pointer value puts its
  134. result in register $2.
  135.  
  136. A function that returns a floating point value returns its value
  137. in register $f0.  Floating-point registers can hold single or
  138. double precision values.
  139.  
  140. The caller to a function the returns a structure or union passes the
  141. address of an area large enough to hold the area (passes it in $4).
  142. Before the function returns to its caller, it will copy the return
  143. structure to the area in memory pointed to by $4.  The function will
  144. also return a pointer to the returned structure in $2.  Having the
  145. caller supply the return object's space allows reentrancy.
  146.  
  147.  */
  148.  
  149.  
  150. #include <theusual.h>
  151. #include <assert.h>
  152. #include <scheme.h>
  153. #include <zelk.h>
  154.  
  155.  
  156. /* FA_MAX is max # of foreign args, counting a double as 2 args.
  157.  * Stack pointer is always double aligned, so this must be EVEN.
  158.  * arg0..3 -> $4..$7
  159.  * arg4         16($sp)
  160.  * arg5         20($sp)
  161.  * argn         (16+4*(n-4))($sp)
  162.  * possibly the longest foreign function currently:
  163.  *(PN3init seed amp pd ncl npt saxis verbose):
  164.   r0    seed    ;offset 0..3 words in registers
  165.   r2,3  amp     
  166.   s4,5  polyd   ;offset >=4 on stack
  167.   s6,7  ncells
  168.   s8    npts
  169.   s9    symaxis
  170.   s10   verbose
  171. */
  172. #define FA_MAX 12        /* 40($sp) */
  173.  
  174. #define FA_FLT  13
  175. #define FA_DBL  14      /* argument type code: double, 8bytes */
  176. #define FA_INT  15      /* int,long,char,short,pointer */
  177.  
  178. /* these globals do not prevent reentrancy-they all get copied to the stack.
  179.  * scheme->c->scheme calling sequences have not arisen yet anyway.
  180.  */
  181. int FA_soff;            /* stack offset, in words not bytes */
  182. int FA_typ0;            /* type of arg0 */
  183. int FA_reg[4];          /* contents of $4..$7 */
  184. int FA_stk[FA_MAX];     /* stack */
  185. double FA_d1,FA_d2;     /* $f12,$f14 */
  186. /* not used float  FA_f1,FA_f2;     /+ $f12,$f14 */
  187.  
  188. double FA_drtn;         /* returned double */
  189. float  FA_frtn;         /* returned float */
  190. int FA_irtn;            /* returned integer */
  191.  
  192. /* provide a correct prototype for the assembler routine */
  193. Object ZLforcall2 P_((function *));
  194.  
  195. #ifdef GENASM
  196. /* assembling this gives ALMOST the code we need */
  197. Object ZLforcall2(func)
  198.   function *func;
  199. {
  200.   FA_drtn = (*func)(FA_d1,FA_reg[2],FA_reg[3],
  201.       FA_stk[4],FA_stk[5],FA_stk[6],FA_stk[7],FA_stk[8],FA_stk[9],
  202.                     FA_stk[10],FA_stk[11]);
  203. }
  204. #else  /*!GENASM*/
  205.  
  206. /*forward*/ static void FA_put Zproto((int,int,int,double));
  207.  
  208. static void
  209. FA_put(iarg,typ,I,D)
  210.   int iarg,typ;
  211.   int I;
  212.   double D;
  213. {
  214.   char *argerr = "foreign args overran stack (use fewer args)";
  215. # define CHKSTK \
  216.   if (FA_soff >= FA_MAX) Primitive_Error(argerr);
  217.  
  218.   CHKSTK
  219.   if (iarg==0) FA_typ0 = typ;
  220.  
  221.   if (typ==FA_DBL) {
  222.  
  223.     if (iarg == 0) {    /* leading float goes in $f12 */
  224.       FA_d1 = D;
  225.       FA_soff += 2;
  226.       Ztrace(("d1\n"));
  227.     }
  228.  
  229.     /* 2 leading floats go in $f12 and $f14 */
  230.     else if ((iarg == 1) &&
  231.              ((FA_typ0 == FA_DBL) || (FA_typ0 == FA_FLT))) { 
  232.       FA_d2 = D;
  233.       FA_soff += 2;
  234.       Ztrace(("d2\n"));
  235.     }
  236.  
  237.     /* int,[int],float, put in registers 6,7 */
  238.     else if (FA_soff <= 2) {
  239.       if (FA_soff==1) FA_soff++;
  240.       FA_reg[2] = *((long *)(&D));
  241.       FA_reg[3] = *((long *)(&D)+1);
  242.       FA_soff += 2;
  243.       Ztrace(("dbl->[r2,r3] i.e. r6,7\n"));
  244.     } /*iarg==1*/
  245.  
  246.     /* remaining args on stack */
  247.     else {
  248.       if ((FA_soff%2) != 0) FA_soff++;  /* double align */
  249.       CHKSTK
  250.       FA_stk[FA_soff] = *((long *)(&D));
  251.       FA_stk[FA_soff+1] = *((long *)(&D)+1);
  252.       Ztrace(("dbl -> s:%d,%d\n",FA_soff,FA_soff+1));
  253.       FA_soff += 2;
  254.     } /*dbl on stk*/
  255.  
  256.   }/*typ==DBL*/
  257.  
  258.  
  259.   else if (typ==FA_FLT) {
  260.  
  261.     if (iarg == 0) {    /* leading float goes in $f12 */
  262.       long *adr = (long *)&FA_d1;
  263.       float f = (float)D;
  264.       *(adr+1) = *(long *)&f; 
  265.       FA_soff ++;
  266.       Ztrace(("f1\n"));
  267.     }
  268.  
  269.     /* 2 leading floats go in $f12 and $f14 */
  270.     else if ((iarg == 1) &&
  271.              ((FA_typ0 == FA_DBL) || (FA_typ0 == FA_FLT)))
  272.     {
  273.       long *adr = (long *)&FA_d2;
  274.       float f = (float)D;
  275.       *(adr+1) = *(long *)&f; 
  276.       FA_soff ++;
  277.       Ztrace(("f2\n"));
  278.     }
  279.  
  280.     /* int,[int],float, put in register 5..7 */
  281.     else if (FA_soff < 4) {
  282.       float f = (float)D;
  283.       FA_reg[FA_soff] = *((long *)(&f));
  284.       Ztrace(("f->[r%d]\n",FA_soff));
  285.       FA_soff ++;
  286.     } /*iarg==1*/
  287.  
  288.     /* remaining args on stack */
  289.     else {
  290.       float f = (float)D;
  291.       CHKSTK
  292.       FA_stk[FA_soff] = *((long *)(&f));
  293.       Ztrace(("flt -> s[%d]\n",FA_soff));
  294.       FA_soff ++;
  295.     } /*flt on stk*/
  296.  
  297.   }/*typ==FLT*/
  298.  
  299.   else {        /* typ==INT */
  300.     /* first 4 in registers */
  301.     if (FA_soff < 4) {
  302.       FA_reg[FA_soff] = I;
  303.       Ztrace(("int -> r:%d\n",FA_soff));
  304.       FA_soff ++;
  305.     }
  306.     /* remainder on stack */
  307.     else {
  308.       FA_stk[FA_soff] = I;
  309.       Ztrace(("int -> s:%d\n",FA_soff));
  310.       FA_soff ++;
  311.     }
  312.   } /*typ==INT*/
  313.  
  314. } /*FA_put*/
  315.  
  316.  
  317. Object ZLforcall(name,func,proto,ac,av)
  318.   char *name;
  319.   function *func;
  320.   unsigned char *proto;
  321.   int ac;
  322.   Object *av;
  323. {
  324.   int i;
  325.   Object arg;
  326.   bool err;
  327.   int4 tmp;
  328.   double dtmp;
  329.   char *cs,*ds;
  330.   int j;
  331.  
  332. # define strheapsize 1024  
  333.   char strheap[strheapsize];
  334.   char *strptr = strheap;
  335.  
  336.   int padding[512];          /* superstitous? make sure enough stack space */
  337.  
  338.   Error_Tag = name;
  339.  
  340.   if (ForeignTracep)
  341.     printf("%s(%s) #args=%d\n",name,ZLforproto(proto),ac);
  342.   else
  343.     Ztrace(("Zforfuncall %s(%s) ac=%d\n",name,ZLforproto(proto),ac));
  344.  
  345.   if (ac > FA_MAX) Primitive_Error("exceeds max #args of foreign function");
  346.  
  347.     /* loop: check argument types, convert int<->flt, stack args.
  348.      * DO NOT DECLARE LOCAL VARIABLES IN BLOCKS BELOW
  349.      * ALSO DO NOT CALL ANY SUBROUTINES
  350.      * variables could occupy the same stack space where
  351.      * the callees frame is being setup (this happened during debugging,
  352.      * see the NONO comment below.
  353.      * ALSO, cannot call any subroutines in this loop, because they
  354.      * may well write over the sp+x44 outparameter assembly area.
  355.      * OR, if calling a subroutine, save this area, and restore it
  356.      * afterwards!
  357.      * NOTE this code depends on T_Returns < T_Ends!!
  358.      */
  359.  
  360.   err = FALSE;
  361.   FA_soff = 0;
  362.   for( i=0; i < ac; i++ ) {
  363.  
  364.     if (!proto || (*proto >= T_Returns)) /* too many arguments given */
  365.       { err = TRUE; break; }
  366.  
  367.     arg = av[i];        /* get supplied argument */
  368.  
  369.     if ((TYPE(arg)==*proto) || ((TYPE(arg)==T_Bignum) && (*proto==T_Fixnum)))
  370.     {
  371.  
  372.       /* T_Farray is not a constant, so it is not part of switch below */
  373.       if (*proto == T_Farray) 
  374.         FA_put(i,FA_INT,(long)(FARRAY(arg)->data),0);
  375.  
  376.       else switch(*proto) {
  377.  
  378.       case T_Flonum:
  379.         /****NO****[double d;]****NO****/
  380.         dtmp = (double)FLONUM(arg)->val;
  381.         FA_put(i,FA_FLT,0,dtmp);
  382.         break;
  383.  
  384.       case T_Fixnum:
  385.         FA_put(i,FA_INT,Get_Integer(arg),0);
  386.         break;
  387.  
  388.       case T_Boolean: 
  389.         FA_put(i,FA_INT,(arg == True) ? 1 : 0,0);
  390.         break;
  391.  
  392.       case T_String:
  393.         /* elk does not null-terminate strings on its heap,
  394.          * so we must create a null-terminated copy, without
  395.          * calling any subroutines.
  396.          */
  397.         if ((strptr + STRING(arg)->size) >= (strheap+strheapsize))
  398.           Primitive_Error("string heap is full");
  399.         for( cs=STRING(arg)->data,ds=strptr,j=STRING(arg)->size; j; j-- )
  400.           *ds++ = *cs++;
  401.         *ds = (char)0;
  402.         FA_put(i,FA_INT,(long)strptr,0);
  403.         strptr += (STRING(arg)->size + 1);
  404.         break;
  405.  
  406.       case T_Port:
  407.         FA_put(i,FA_INT,(long)PORT(arg)->file,0);
  408.         break;
  409.  
  410.       default:
  411.         Primitive_Error("bad type");
  412.         break;
  413.  
  414.       } /*switch*/
  415.     } /* TYPE(arg)==*proto */
  416.  
  417.  
  418.  /* int<->flt type conversion */
  419.     else {
  420.       if ((*proto == T_Flonum)
  421.           && ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)))
  422.       {
  423.         dtmp = (double)Get_Integer(arg);
  424.         FA_put(i,FA_FLT,0,dtmp);
  425.       }
  426. # ifdef T_Double
  427.       if (*proto == T_Double) {
  428.         if ((TYPE(arg)==T_Fixnum) || (TYPE(arg)==T_Bignum)) {
  429.           dtmp = (double)Get_Integer(arg);
  430.           FA_put(i,FA_DBL,0,dtmp);
  431.         }
  432.         else if (TYPE(arg)==T_Flonum) {
  433.           dtmp = FLONUM(arg)->val;
  434.           FA_put(i,FA_DBL,0,dtmp);
  435.         }
  436.         else {
  437.           err = TRUE; break;
  438.         }
  439.       }
  440. # endif
  441.       else if ((*proto == T_Fixnum) && (TYPE(arg)==T_Flonum)) {
  442.         tmp = (int)(double)FLONUM(arg)->val;
  443.         FA_put(i,FA_INT,tmp,0);
  444.       }
  445.       else {
  446.         printf("proto=%d, TYPE(arg)=%d\n",*proto,TYPE(arg)); fflush(stdout);
  447.         err = TRUE; break;
  448.       }
  449.     } /*convert type*/
  450.  
  451.     proto++;
  452.   } /*argstackloop*/
  453.  
  454.  
  455.   if (err || (proto && (*proto < T_Returns))) {
  456.     printf("(...%s): ",ZLforproto(proto)); /*&HERE*/
  457.     Primitive_Error("incorrect arguments");
  458.   }
  459.  
  460.   ZLforcall2(func);
  461.   Ztrace(("--ZLforfcall2 rtns(%d %f)\n",FA_irtn,FA_drtn));
  462.  
  463.   if (*proto++ == T_Returns) {
  464.     Ztrace(("returning..."));
  465.  
  466.     if (*proto == T_Boolean) {
  467.       Ztrace(("returning boolean %d\n",FA_irtn));
  468.       return( FA_irtn ? True : False );
  469.     }
  470.  
  471.     else if (*proto == T_Fixnum) {
  472.       Ztrace(("returning int %d\n",FA_irtn));
  473.       return(Make_Integer(FA_irtn));
  474.     }
  475.  
  476.     else if (*proto == T_String) {
  477.       if (FA_irtn == 0) return(Null);
  478.       /* note elk does not null-terminate strings on its heap */
  479.       return(Make_String((char *)FA_irtn, str_len((char *)FA_irtn)));
  480.     }
  481.  
  482.     else if (*proto == T_Flonum) {
  483.       Ztrace(("returning float %f\n",FA_frtn));
  484.       return Make_Reduced_Flonum( FA_frtn );
  485.     }
  486.  
  487.     else if (*proto == T_Double) {
  488.       Ztrace(("returning double %f\n",FA_drtn));
  489.       return Make_Reduced_Flonum( FA_drtn );
  490.     }
  491.  
  492.     else if (*proto == T_Port) {
  493.       FILE *f = (FILE *)FA_irtn;
  494.       return Make_Port( (f->_flag&_IOREAD) ? P_INPUT : 0,
  495.                        f, Make_String("foreign-port",12));
  496.     }
  497.  
  498.     else Primitive_Error("bad return spec.");
  499.   } /*get return value*/
  500.  
  501.   return Null;
  502. } /*ZLforcall*/
  503.  
  504. #endif /*!GENASM*/
  505.